home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Zoom 2
/
Zoom - Release 2 (1996)(Active Software)[!].iso
/
misc
/
scion409
/
scionarexx.lha
/
PrintPedigree.rexx
< prev
next >
Wrap
OS/2 REXX Batch file
|
1995-09-21
|
21KB
|
741 lines
/****************************************************************************
* *
* $VER: PrintPedigree 2.03 (9 Sep 1995)
* *
* Written by Freddy Ariës *
* *
* Output options: *
* 1. Pedigree Chart - male ancestor line only [Dutch: stamreeks] *
* 2. Pedigree Chart - all ancestors, no siblings [Dutch: kwartierstaat] *
* 3. Pedigree Chart - all ancestors, only siblings of last generation *
* 4. Pedigree Chart - all ancestors, all siblings *
* *
* This script uses (by default) the rexxreqtools.library (which requires *
* a version of reqtools larger than 2.0 and rexxsyslib.library) *
* If you do not have these, you need to supply the NOREQ argument (for *
* Shell output), or the QUIET argument (for no output at all). *
* *
* As of v2 of this script, and Scion V4, the current person on Scion's *
* Personal Window will be used to determine where the search starts. *
* Scion 3.13 can still be used, though, in which case the user will be *
* asked at which IRN he wants to start. *
* *
* TO DO (low priority, unless someone really wants this): *
* - count the number of lines output and give a formfeed after a *
* certain number (ie. skip page breaks) *
* - Add a menu option for the maximum number of generations to print *
* - allow user to specify if he wants burial data, occupation, comments, *
* references fields, etc. printed *
* - option: include empty fields *
* - find a good way to handle sex-fields with value '?' (see below) *
* - Suggestions, comments, bugreports, donations, etc. are appreciated. *
* *
* Known Bugs/Problems: *
* - This script is dog slow for large databases (ie. more than, say, 10 *
* generations), even on Amigas with a Turboboard! *
* - Incorrect assumptions may be made (with regard to father/mother) when *
* there are persons in the database whose sex-field has value '?' *
* *
****************************************************************************/
options results
arg prtin outname noirn mgen outval
versionstr = "2.03"
usereq = 1; /* change this to 0 if you don't want to use reqtools */
outp = 1; useirn = 1; prtdev = stdout; prtopt = 0
plwidth = 78; /* linewidth of the printer */
NL = '0A'x
PSCR = 'SCIONGEN'; /* public screen to open the requesters on */
numpers = 1
DbtGen = 12; /* Suggested value for 68000: 10, with Turbo-boards: 12 */
/* From this generation onwards, every generation needs a confirm */
/* Note: 12 generations means (up to) 4096 persons!!! */
signal on IOERR
/* parse command line options, to allow calling the script automatically,
* eg. from a function key
*/
do while prtin = '?'
Tell("NUMOPT/A/N,OUTFILE/A,NOIRN/S,MAXGEN/N,QUIET/S,NOREQ/S: ")
pull prtin outname noirn mgen outval
end
ParseArguments()
if usereq & ~show('l','rexxreqtools.library') then do
if exists('libs:rexxreqtools.library') then
call addlib('rexxreqtools.library',0,-30,0)
else do
usereq = 0; outp = 1
Tell("Unable to open rexxreqtools.library - using text output")
end
end
/* These first few lines were stolen from Peter Billings - thanks Peter ;-) */
if ~show('P','SCIONGEN') then do
TermError('I am sorry to say that the SCION Genealogist' || NL ||,
'database is not available. Please start the' || NL ||,
'SCION program BEFORE using this script!')
end
myport = "SCIONGEN"
address value myport
GETDBNAME
dbname = upper(RESULT)
GETPROGVERSION
progvers = RESULT
if progvers >= 4 then do
GETCURRENTIRN
irn = RESULT
end
if outp & ~usereq then do
Tell("*** PrintPedigree version "||versionstr||" ***")
Tell("*** by Freddy Ariës ***")
Tell("Current database: "||dbname||NL)
end
if prtopt = 0 then do
/* No use in asking for input if we're not allowed to output anything */
if usereq then do
prtopt = rtezrequest('Current Scion database: '||dbname||NL||,
NL||'Please make your choice: '||,
NL||'1. Pedigree Chart - male ancestor line only'||,
NL||'2. Pedigree Chart - all ancestors, no siblings'||,
NL||'3. Pedigree Chart - all ancestors, only last generation siblings'||,
NL||'4. Pedigree Chart - all ancestors, all siblings'||,
'',' _1 | _2 | _3 | _4 |E_xit','PrintPedigree v'||versionstr||' by Freddy Ariës','rt_pubscrname = '||PSCR)
if prtopt = 0 then
EXIT
if progvers < 4 then do
irn = rtgetlong(,'Enter the IRN of the person whose'||,
NL||'ancestors you want to print: '||,
NL,'Input Request:','_Continue','rt_pubscrname = '||PSCR)
if irn = '' then
EXIT
irn = abs(irn)
end
useirn = rtezrequest('Do you want to output the IRNs'||,
NL||'(the record numbers) as well?'||,
'',' _Yes| _No ','Input Request:','rt_pubscrname = '||PSCR)
end
else do
Tell("1. Pedigree Chart - male ancestor line only")
Tell("2. Pedigree Chart - all ancestors, no siblings")
Tell("3. Pedigree Chart - all ancestors, only siblings of last generation")
Tell("4. Pedigree Chart - all ancestors, all siblings")
TellNN("Your choice: ")
pull prtopt
prtopt = CheckAnswer(prtopt)
if progvers < 4 then do
TellNN("Enter the IRN of the person whose ancestors you want to print: ")
pull irn
end
TellNN("Do you want to output the IRN (numbers) as well (y/n)? ")
pull instr
Tell("")
if left(instr, 1) = "Y" | left(inp, 1) = "y" then useirn = 1
else useirn = 0
end
end
if progvers < 4 then do
irn = CheckIRN(irn)
end
EXISTPERSON irn
if RESULT ~= 'YES' then
do
if progvers >= 4 then
TermError("Unable to determine current person in the database.")
else
TermError("No person with IRN "||irn||" in the current database.")
end
if outp then do
pname = GetNameStr(irn, 0)
if usereq then do
valcont = rtezrequest('The selected person is: '||NL||pname||'.'||,
NL||'Continue?','_Continue| _Abort','PrintPedigree Request:','rt_pubscrname = '||PSCR)
if valcont = 0 then
EXIT
end
else do
TellNN("Current person is "||pname||". Continue? (y/n) ")
pull valcont
if left(valcont, 1) ~= 'Y' then
TermError("Ok.")
end
end
if outp & outname = "" then do
if usereq then do
odev = rtezrequest('Current Scion database: '||dbname||,
NL||'Where should the output be sent to?'||,
NL,' _File |_Printer|_Screen|_Nowhere','PrintPedigree v'||versionstr||' by Freddy Ariës','rt_pubscrname = '||PSCR)
select
when odev = 1 then do
/* We need a file requester for further data */
dblen = length(dbname)
if dblen>6 & right(dbname, 6)=".SCION" then
dbname=left(dbname, dblen - 6)
outname = rtfilerequest(,dbname||'.PED','Output filename',,'rtfi_buffer = true rt_pubscrname = '||PSCR||' rtfi_initialpath = RAM:',)
if outname = '' then
outname = dbname||'.PED'
end
when odev = 2 then
outname = 'PRT:'
when odev = 3 then
outname = 'STDOUT'
otherwise
EXIT
/* You selected 'Nowhere' */
end
end
else do
Tell("Enter output file (filename with complete path, or PRT: for printer,")
TellNN("or STDOUT for screen): ")
pull outname
if outname = "" then
outname = "STDOUT"
end
end
/* Anyone know a better way to translate numbers into Roman? */
GenerationS.1 = "I II III IV V VI VII VIII IX X XI XII XIII XIV XV XVI XVII XVIII XIX XX"
GenerationS.2 = "XXI XXII XXIII XXIV XXV XXVI XXVII XXVIII XXIX XXX XXXI XXXII XXXIII XXXIV XXXV XXXVI XXXVII XXXVIII IXL XL"
/* Printer Codes (some of which are currently unused): */
ESC = '1B'x
prtinit = ESC||"#1"; /* ESC#1 initialize */
prtundon = ESC||"[4m"; /* ESC[4m underline on */
prtundoff = ESC||"[24m"; /* ESC[24m underline off */
prtdson = ESC||"[1m"; /* ESC[1m boldface on */
prtdsoff = ESC||"[22m"; /* ESC[22m boldface off */
prtnlqon = ESC||"[2"||'22'x||"z"; /* ESC[2"z NLQ on */
prtnlqoff = ESC||"[1"||'22'x||"z"; /* ESC[1"z NLQ off */
if ~usereq then
Tell("Building ancestor table...")
currgen = 1
GENTREE.1 = irn
/* Build the ancestor table */
do until ~foundone
foundone = 0
currgen = currgen + 1
numpers = 2 * numpers
/* = 2 ** (currgen - 1) */
if currgen <= MaxGens then
do
if currgen > DbtGen then
do
if usereq then
do
docont = rtezrequest('Also parse generation '||currgen||' ?'||,
NL||'(this may take *very* long!)'||,
'',' _Yes| _No ','Input Request:','rt_pubscrname = '||PSCR)
end
else
do
Tell("Also parse generation '||currgen||' ?' (this may take *very* long!)")
pull inp
Tell("")
if left(inp, 1) = "Y" | left(inp, 1) = "y" then docont = 1
else docont = 0
end
end
else docont = 1
if docont then
do
if prtopt = 1 then
endnum = numpers+1
/* no use to build the entire table, if we need only this little */
else
endnum = 2*numpers-1
/*
* TO DO: at the moment, all the numbers are parsed, even if there
* is only one family group with ancestors in this generation
* This means that thousands of fields may be checked, to find
* two persons. This also makes the program dog slow!
* I must find a better method to do this. Suggestions welcome...
*/
do ct = numpers to endnum by 2
ct1 = ct % 2
irn = GENTREE.ct1
ct1 = ct + 1
GENTREE.ct = 0
GENTREE.ct1 = 0
if irn ~= 0 then do
GETPARENTS irn
fgrn = RESULT
EXISTFAMILY fgrn
if RESULT = 'YES' then do
foundone = 1
GetParentsIRN(fgrn, ct, ct1)
end
end
end
end
end
else do
if usereq then
rtezrequest('Maximum number of'||NL||'generations reached.'||NL||,
NL||'Output truncated','_Continue','PrintPedigree Message:','rt_pubscrname = '||PSCR)
else
Tell("Maximum number of generations reached. Output may be truncated.")
end
end
numgens = currgen - 1
/* Now print all the ancestors */
if ~usereq then
Tell("Printing data...")
OpenPrinter()
if prtopt = 1 then do
/* print only male ancestors */
fill = 7
np = numpers%2
currgen = 1
do while np > 1
g1 = GetGenStr(currgen, fill)
ct1 = np + 1
ct2 = np % 2
/* get the husband's data */
g1 = g1||GetPersonStr(GENTREE.np)
GETPARENTS GENTREE.ct2
mf1 = RESULT
EXISTFAMILY mf1
if RESULT = 'YES' then
m1 = GetMarriageStr(mf1)
else
m1 = ""
if m1 ~= "" then
m1 = g1||", m: "||m1
else m1 = g1
g1 = copies(' ',fill)
PrintLines(m1, fill)
/* get the wife's data */
m1 = g1||GetPersonStr(GENTREE.ct1)
PrintLines(m1, fill)
PrintLF()
currgen = currgen + 1
np = np % 2
end
g1 = GetGenStr(currgen, fill)||GetPersonStr(GENTREE.np)
g1 = g1||GetMarriages(GENTREE.np)
PrintLines(g1, fill)
PrintLF()
end
else do
/* print all */
currgen = currgen - 1
fill = 6
g1 = center("Generation: "||GetGenStr(currgen, fill), plwidth-1)
PrintLines(g1, fill)
g1 = "1. "||GetPersonStr(GENTREE.1)
g1 = g1||GetMarriages(GENTREE.1)
PrintLines(g1, fill)
if prtopt > 2 then
PrintSiblings(GENTREE.1, 1)
PrintLF()
np = 2
currgen = currgen - 1
do while np < numpers
g1 = center("Generation: "||GetGenStr(currgen, fill), plwidth)
PrintLines(g1, fill)
endnum = 2*np-1
do ct = np to endnum by 2
ct1 = ct + 1
ct2 = ct % 2
/* print the principal data */
if GENTREE.ct ~= 0 then do
g1 = left(ct||". ",fill)||GetPersonStr(GENTREE.ct)
GETPARENTS GENTREE.ct2
mf1 = RESULT
EXISTFAMILY mf1
if RESULT = 'YES' then
m1 = GetMarriageStr(mf1)
else
m1 = ""
if m1 ~= "" then
m1 = g1||", m: "||m1
else m1 = g1
g1 = copies(' ',fill)
PrintLines(m1, fill)
if prtopt = 4 then
PrintSiblings(GENTREE.ct, ct)
end
/* print the spouse data */
if GENTREE.ct1 ~= 0 then do
m1 = left(ct1||". ",fill)||GetPersonStr(GENTREE.ct1)
PrintLines(m1, fill)
if prtopt = 4 then
PrintSiblings(GENTREE.ct1, ct1)
end
end
PrintLF()
currgen = currgen - 1
np = np * 2
end
end
if numgens = 1 then
PrintLines("No ancestors are recorded for this person.", 0)
if usereq then
rtezrequest('Output ready.','_Continue','PrintPedigree Message:','rt_pubscrname = '||PSCR)
else
Tell("Done.")
writeln(prtdev, prtnlqoff); /* ESC[1"z NLQ off */
close(prtdev)
EXIT
/* Parse command line arguments and set the appropriate global variables */
ParseArguments:
if noirn = "NOIRN" then useirn = 0
else if noirn = "QUIET" || noirn = "NOREQ" then do
outval = noirn
noirn = ""
end
else do
outval = mgen
mgen = noirn
noirn = ""
end
if mgen = "QUIET" || mgen = "NOREQ" then do
outval = mgen
mgen = ""
end
MaxGens = 20
/* due to the Roman numbers, we can't handle more than 40 */
/* but due to speed limitations, I don't advise using more than 20 */
if mgen ~= "" then do
if DATATYPE(mgen, 'w') & mgen > 0 & mgen < MaxGens then
MaxGens = mgen
end
if outval = "QUIET" then do
usereq = 0
outp = 0
end
else if outval = "NOREQ" then
usereq = 0
/* if outname = "" then */
/* outname = "STDOUT" */
if prtin = "" then do
prtopt = 0
if ~outp then TermError("Requires argument is missing.")
/* actually, with outp = 0, all it does is EXIT */
end
else do
prtopt = CheckAnswer(prtin)
/* Note that it was important to establish outp before calling these */
end
return 0
OpenPrinter:
/* Open the printer device and print out a nice header */
if outname = "STDOUT" then
prtdev = stdout
else do
prtdev = "PRINTER"
if ~open(prtdev, outname, 'w') then
TermError("ERROR: Failed to open output file!")
end
writeln(prtdev, prtinit||prtnlqon)
if prtopt = 1 then
prtstr = "PEDIGREE CHART - MALE ANCESTOR LINE ONLY"
else if prtopt = 2 then
prtstr = "PEDIGREE CHART - ALL ANCESTORS, NO SIBLINGS"
else if prtopt = 3 then
prtstr = "PEDIGREE CHART - ALL ANCESTORS, ONLY SIBLINGS OF LAST GENERATION"
else
prtstr = "PEDIGREE CHART - ALL ANCESTORS, ALL SIBLINGS"
prtstr = prtundon||prtdson||prtstr||prtdsoff||prtundoff
writeln(prtdev, prtstr)
prtstr = prtdson||"Report printed on: "||date()||prtdsoff
writeln(prtdev, prtstr)
prtstr = copies('=', plwidth)
writeln(prtdev, prtstr)
return 0
PrintLines: PROCEDURE EXPOSE prtdev plwidth prtopt
parse arg ostr, fill
/* TO DO:
* if there are control strings within ostr (like prtdson or prtdsoff)
* don't include them in the length count
*/
do while ostr ~= ""
nnl = plwidth+1
if length(ostr) > plwidth then do
do until pc = ' ' | nnl = 1
pc = substr(ostr, nnl, 1)
nnl = nnl - 1
end
if nnl = 1 then do
prtstr = left(ostr, plwidth)
ostr = delstr(ostr, 1, nnl)
end
else do
prtstr = left(ostr, nnl)
ostr = delstr(ostr, 1, nnl+1)
end
end
else do
prtstr = ostr
ostr = ""
end
writeln(prtdev, prtstr)
if ostr ~= "" then
ostr = copies(' ',fill)||ostr
end
return 0
PrintLF:
writeln(prtdev, "")
return 0
PrintSiblings: PROCEDURE EXPOSE prtdev plwidth prtopt useirn
parse arg inum, prenum
GETPARENTS inum
famfgrn = RESULT
EXISTFAMILY famfgrn
if RESULT ~= 'YES' then return 0; /* no parents, then no siblings */
ix = 0; chnum = 0
do until ischld ~= 'YES'
GETCHILD famfgrn ix
prsn = RESULT
EXISTPERSON prsn
ischld = RESULT
if ischld = 'YES' & prsn ~= inum then do
chnum = chnum + 1
ostr = copies(' ',7)||prenum||D2C(chnum+96)". "||GetPersonStr(prsn)
PrintLines(ostr, 11)
if chnum = 26 then return 0; /* 'z': can't handle more than 26 children */
end
ix = ix + 1
end
return 0
GetGenStr: PROCEDURE EXPOSE prtopt GenerationS.
parse arg gnum, fill
if gnum <= 20 then
gstr = word(GenerationS.1, gnum)
else if gnum <= 40 then
gstr = word(GenerationS.2, gnum)
else
return ""
if prtopt = 1 then gstr = left(gstr||". ",fill)
return gstr
GetPersonStr: PROCEDURE EXPOSE useirn
parse arg irn
if irn ~= 0 then do
nstr = GetNameStr(irn)
nstr = nstr||GetBirthStr(irn)
nstr = nstr||GetDeathStr(irn)
end
else
nstr = "UNKNOWN"
return nstr
GetNameStr: PROCEDURE EXPOSE useirn
parse arg gnum
/* prtdson = '1B'x||"[1m"; * ESC[1m boldface on */
/* prtdsoff = '1B'x||"[22m"; * ESC[22m boldface off */
GETFIRSTNAME gnum
name = RESULT
if name ~= "" then name = name||" "
GETLASTNAME gnum
lname = RESULT
if lname = "" then lname = "UNKNOWN"
name = name||lname
/* another option: name = name||prtdson||lname||prtdsoff
* Problem: see PrintLines
*/
if useirn then name = name||" ["gnum"]"
return name
GetBirthStr: PROCEDURE
parse arg gnum
GETBIRTHPLACE gnum
bstr = RESULT
GETBIRTHDATE gnum
bdat = RESULT
if bdat ~= "" & bstr ~= "" then bstr = bstr||" "
bstr = bstr||bdat
if bstr ~= "" then bstr = ", b: "||bstr
return bstr
GetDeathStr: PROCEDURE
parse arg gnum
GETDEATHPLACE gnum
dstr = RESULT
GETDEATHDATE gnum
ddat = RESULT
if ddat ~= "" & dstr ~= "" then dstr = dstr||" "
dstr = dstr||ddat
if dstr ~= "" then dstr = ", d: "||dstr
return dstr
GetMarriages: PROCEDURE EXPOSE useirn
parse arg irn
mstr = ""
GETMARRIAGE irn 0
mf = RESULT
EXISTFAMILY mf
if RESULT = 'YES' then do
mtrue = 1
GETMARRIAGE irn 1
m2 = RESULT
EXISTFAMILY m2
if RESULT = 'YES' then mset = 1
else mset = 0
end
else
mtrue = 0
mnum = 0
do while mtrue
m1 = GetMarriageStr(mf)
if m1 ~= "" then m1 = m1||' '
ptn = GetPartnerIRN(mf, irn)
m1 = m1||GetPersonStr(ptn)
mnum = mnum + 1
if mset then mstr = mstr||", m("||mnum||"): "||m1
else mstr = mstr||", m: "||m1
GETMARRIAGE irn mnum
mf = RESULT
EXISTFAMILY mf
if RESULT ~= 'YES' then mtrue = 0
end
return mstr
GetMarriageStr: PROCEDURE
parse arg mf
GETMARRYPLACE mf
mstr = RESULT
GETMARRYDATE mf
mdat = RESULT
if mdat ~= "" & mstr ~= "" then mstr = mstr||" "
mstr = mstr||mdat
return mstr
GetParentsIRN: PROCEDURE EXPOSE GENTREE.
parse arg fnum, ct, ct1
fath = 0; moth = 0
GETSPOUSE fnum
sps = RESULT
EXISTPERSON sps
if RESULT = 'YES' then do
GETSEX sps
if RESULT = 'M' then
fath = sps
else moth = sps
end
GETPRINCIPAL fnum
prn = RESULT
/* If there are two mothers, or two fathers, then name the principal
* as 'father' and the spouse as 'mother'
*/
EXISTPERSON prn
if RESULT = 'YES' then do
GETSEX prn
if RESULT = 'M' then do
if fath ~= 0 then
moth = sps
fath = prn
end
else if moth ~= 0 then
fath = prn
else
moth = prn
end
GENTREE.ct = fath
GENTREE.ct1 = moth
return 0
GetPartnerIRN: PROCEDURE
parse arg fnum, inum
GETPRINCIPAL fnum
prn = RESULT
GETSPOUSE fnum
sps = RESULT
if inum = prn then pnum = sps
else if inum = sps then pnum = prn
else pnum = 0
return pnum
CheckAnswer: PROCEDURE EXPOSE outp prtdev usereq
parse arg str
str = left(str, 1)
if ~DATATYPE(str, 'w') then
TermError("Arg(1): not a valid option number.")
if str < 1 | str > 4 then
TermError("Arg(1): not a valid option number.")
return str
CheckIRN: PROCEDURE EXPOSE outp prtdev usereq
parse arg str
if ~DATATYPE(str, 'w') then
TermError("Arg(2): not a valid IRN..")
return str
Tell: PROCEDURE EXPOSE outp
parse arg str
if outp then
writeln(stdout, str)
return 0
TellNN: PROCEDURE EXPOSE outp
/* Tell, No Newline */
parse arg str
if outp then
writech(stdout, str)
return 0
TermError: PROCEDURE EXPOSE outp prtdev usereq PSCR
parse arg str
/* If you turned off stdout, no error messages will be shown! */
if usereq then
rtezrequest(str,'E_xit','PrintPedigree Message:','rt_pubscrname = '||PSCR)
else do
Tell(str || '0A'x)
end
close(prtdev)
EXIT
/* Let's make sure you get a nice message when you turn off the printer :-) */
IOERR:
bline = SIGL
say "I/O error #"||RC||" detected in line "||bline||":"
say sourceline(bline)
EXIT